home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / pr_decl.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  2.2 KB  |  91 lines  |  [TEXT/MPS ]
  1. (* To print the things defined by an implementation *)
  2.  
  3. #open "misc";;
  4. #open "const";;
  5. #open "globals";;
  6. #open "pr_type";;
  7.  
  8. let print_expr ty =
  9.   print_string "(* - : ";
  10.   print_one_type ty;
  11.   print_endline " *)";
  12.   flush std_out
  13. ;;
  14.  
  15. let print_valdef env =
  16.   do_list
  17.     (fun (name, (typ, mut_flag)) ->
  18.       print_string "value "; print_string name;
  19.       print_string " : "; print_one_type typ;
  20.       print_endline ";;")
  21.     env;
  22.   flush std_out
  23. ;;
  24.  
  25. let print_constr_decl cstr =
  26.   print_string cstr.qualid.id;
  27.   begin match cstr.info.cs_kind with
  28.     Constr_constant -> ()
  29.   | _ ->
  30.       print_string " of ";
  31.       begin match cstr.info.cs_mut with
  32.           Mutable -> print_string "mutable "
  33.         |     _   -> ()
  34.       end;
  35.       print_type cstr.info.cs_arg
  36.   end;
  37.   print_endline ""
  38. ;;
  39.  
  40. let print_label_decl lbl =
  41.   begin match lbl.info.lbl_mut with
  42.       Mutable -> print_string "mutable "
  43.     |     _   -> ()
  44.   end;
  45.   print_string lbl.qualid.id;
  46.   print_string " : ";
  47.   print_type lbl.info.lbl_arg;
  48.   print_endline ""
  49. ;;  
  50.  
  51. let print_one_typedecl (ty_res, ty_comp) =
  52.   reset_type_var_name();
  53.   print_type ty_res;
  54.   begin match ty_comp with
  55.     Variant_type(cstr1::cstrl) ->
  56.       print_endline " = ";
  57.       print_string "    "; print_constr_decl cstr1;
  58.       do_list (fun cstr -> print_string "  | "; print_constr_decl cstr) cstrl
  59.   | Record_type(lbl1::lbll) ->
  60.       print_endline " = ";
  61.       print_string "  { "; print_label_decl lbl1;
  62.       do_list (fun lbl -> print_string "  ; "; print_label_decl lbl) lbll;
  63.       print_endline "  }"
  64.   | Abbrev_type(_, ty_body) ->
  65.       print_string " == "; print_type ty_body; print_endline ""
  66.   | Abstract_type ->
  67.       print_endline ""
  68.   end
  69. ;;
  70.  
  71. let print_typedecl = function
  72.     [] -> fatal_error "print_typedecl"
  73.   | dcl1::dcll ->
  74.       print_string "type "; print_one_typedecl dcl1;
  75.       do_list (fun dcl -> print_string " and "; print_one_typedecl dcl) dcll;
  76.       print_string ";;"; print_newline()
  77. ;;
  78.  
  79. let print_excdecl = function
  80.     Variant_type cstrl ->
  81.       do_list
  82.         (fun cstr ->
  83.           reset_type_var_name();
  84.           print_string "exception ";
  85.           print_constr_decl cstr)
  86.         cstrl;
  87.       print_string ";;"; print_newline()
  88.   | _ ->
  89.       fatal_error "print_excdecl"
  90. ;;
  91.